unit PtEvents;

interface

uses
  SysUtils, Classes, Generics.Collections;

{ $DEFINE DEBUG_EVENTS}

type
  TEvents = class
  private type

    TEvent = record
      Callback: TNotifyEvent;
{$IFDEF DEBUG_EVENTS}
      CallbackDesc: string;
{$ENDIF}
      constructor Create(const ACallback: TNotifyEvent);
    end;

    TMethodsObject = class(TInterfacedObject, IEnumerator)
    private
      fOwner: TEvents;
      fIndex: integer;
    public
      procedure Expire; inline;
      //  IEnumerator interface
      function GetCurrent: TObject;
      function MoveNext: Boolean;
      procedure Reset;
    end;

    TMethodsGeneric = class(TMethodsObject, IEnumerator<TNotifyEvent>)
    private
      procedure Removing(const Index: integer);
      constructor Create(const AOwner: TEvents);
    public
      destructor  Destroy; override;
      //  IEnumerator<T> interface
      function GetCurrent: TNotifyEvent;
    end;

  public
    function GetEnumerator: IEnumerator<TNotifyEvent>;
  private
    fEvents : TList<TEvent>;
    fEnumerators: TList<TMethodsGeneric>;
    fEnabled: Boolean;
    fOwner: TObject;
{$IFDEF DEBUG_EVENTS}
    fOwnerName: string;
{$ENDIF}
    function GetCount: integer; inline;
    function GetEnabled: Boolean;
  protected
{$IFDEF DEBUG_EVENTS}
    function  OwnerDesc: string;
{$ENDIF}
    function  IsSameMethod(const Event1, Event2: TNotifyEvent): Boolean;
    function  IndexOf(const Event: TNotifyEvent): integer;
    procedure InternalSubscribe(const Callback: TNotifyEvent);
    procedure InternalUnsubscribe(const Callback: TNotifyEvent);
    property  Count: integer  read GetCount;
  public
    constructor Create(const AOwner: TObject);
    destructor  Destroy; override;
    property  Owner   : TObject read fOwner;
    property  Enabled : Boolean read GetEnabled write fEnabled;
    procedure Clear;
    //  How to's
  //procedure Call(Parameters: TObject);
  //procedure Subscribe(const Event: TMyEventType);
  //procedure Unsubscribe(const Event: TMyEventType);
  end;

  EEvents = class(Exception);

  TNotifyEvents = class(TEvents)
  public
    procedure Call;
    function  IsSubscribed(const Event: TNotifyEvent): Boolean;
    procedure Subscribe(const Event: TNotifyEvent);
    procedure Unsubscribe(const Event: TNotifyEvent);
    procedure TryUnsubscribe(const Event: TNotifyEvent);
  end;

  TEvent1Param<TParam> = class(TEvents)
  public type
    TCallback1Param = procedure(Sender: TObject; Param: TParam) of object;
  public
    procedure Call(Param: TParam);
    procedure Subscribe(const Event: TCallback1Param);
    procedure Unsubscribe(const Event: TCallback1Param);
  end;

{$IFDEF DEBUG_EVENTS}
  EventsStates = class
  private type

    TState = record
      Events: TEvents;
      IsFreed: Boolean;
      EventsClassName: string;
      OwnerClassName: string;
      constructor Create(const AEvents: TEvents);
    end;

  private
    class var _States: TList<TState>;
    class function  IndexOf(const Events: TEvents): integer;
    class procedure Register(const Events: TEvents);
    class procedure Unregister(const Events: TEvents);
    class function  GetTotal: integer; static;
  public
    class constructor Create;
    class destructor  Destroy;
    class property  Total   : integer read GetTotal;
  end;

  EEventsStates = class(Exception);
{$ENDIF}

var
  DisableAllEvents  : Boolean = False;

implementation

uses
  RTTI, FMX.Dialogs;

{ TEvents.TEvent }

constructor TEvents.TEvent.Create(const ACallback: TNotifyEvent);
var
  Method: TMethod absolute ACallback;

  function FindMethodName: string;
  var
    Ctx: TRttiContext;
    Meths: TArray<TRttiMethod>;
    Meth: TRttiMethod;
  begin
    Ctx := TRttiContext.Create;
    try
      Meths := Ctx.GetType(TObject(Method.Data).ClassType).GetMethods;
      for Meth in Meths do
        if Meth.CodeAddress = Method.Code then
          Exit(Meth.Name);
      Result  := '<method not published>';
    finally
      Ctx.Free;
    end;
  end;

begin
  Callback  := ACallback;
{$IFDEF DEBUG_EVENTS}
  if  Assigned(ACallback) then
    CallbackDesc := TObject(Method.Data).ClassName + '.' + FindMethodName + '()'
  else
    CallbackDesc := 'nil callback object';
{$ENDIF}
end;

{ TEvents.TMethodsObject }

procedure TEvents.TMethodsObject.Expire;
begin
  fIndex  := MaxInt;
end;

function TEvents.TMethodsObject.GetCurrent: TObject;
begin
  raise EEvents.Create(ClassName + ' does not return objects.');
end;

function TEvents.TMethodsObject.MoveNext: Boolean;
begin
  Result  := fIndex < fOwner.fEvents.Count - 1;
  if  Result  then
    inc(fIndex);
end;

procedure TEvents.TMethodsObject.Reset;
begin
  fIndex  := -1;
end;

{ TEvents.TMethodsGeneric }

constructor TEvents.TMethodsGeneric.Create(const AOwner: TEvents);
begin
  inherited Create;
  fOwner  := AOwner;
  fOwner.fEnumerators.Add(Self);
  Reset;
end;

destructor TEvents.TMethodsGeneric.Destroy;
begin
  fOwner.fEnumerators.Remove(Self);
  inherited;
end;

function TEvents.TMethodsGeneric.GetCurrent: TNotifyEvent;
begin
  Result  := fOwner.fEvents[fIndex].Callback
end;

procedure TEvents.TMethodsGeneric.Removing(const Index: integer);
begin
  if  Index <= fIndex then
    dec(fIndex);
end;

{ TEvents }
{
    Because TEvents stores callbacks as TNotifyEvent, we need to typecast
    the events back to the actual event type, followed by parameters.

procedure TEvents<TMyEventType>.Call(Parameters: TObject);
var
  Event : TNotifyEvent;
begin
  if  Enabled then
    for Event in Self do
      TMyEventType(Event)(Owner, Parameters)
end;
}
procedure TEvents.Clear;
begin
  fEvents.Clear;
end;

constructor TEvents.Create(const AOwner: TObject);
begin
  inherited Create;
  fOwner    := AOwner;
  fEnabled  := True;
  fEvents   := TList<TEvent>.Create;
  fEnumerators  := TList<TMethodsGeneric>.Create;
{$IFDEF DEBUG_EVENTS}
  if  Assigned(fOwner)  then
    fOwnerName  := fOwner.ClassName
  else
    fOwnerName  := 'nil owner';
  EventsStates.Register(Self);
{$ENDIF}
end;

destructor TEvents.Destroy;
var
  Enumerator: TMethodsGeneric;
begin
  for Enumerator in fEnumerators  do
    Enumerator.Expire;
{$IFDEF DEBUG_EVENTS}
  EventsStates.Unregister(Self);
{$ENDIF}
  fEnumerators.Free;
  fEvents.Free;
  inherited;
end;

function TEvents.GetCount: integer;
begin
  Result  := fEvents.Count
end;

function TEvents.GetEnabled: Boolean;
begin
  Result := fEnabled and not DisableAllEvents
end;

function TEvents.GetEnumerator: IEnumerator<TNotifyEvent>;
begin
  Result  := TMethodsGeneric.Create(Self);
end;

function TEvents.IndexOf(const Event: TNotifyEvent): integer;
begin
  Result  := fEvents.Count - 1;
  while Result >= 0 do
    begin
      if  IsSameMethod(Event, fEvents[Result].Callback) then
        break;
      dec(Result);
    end;
end;

procedure TEvents.InternalSubscribe(const Callback: TNotifyEvent);
var
  i : integer;
begin
  if  DisableAllEvents  then
    exit;
  //  Avoid duplicate entries
  i := IndexOf(Callback);
  if  i < 0 then
    fEvents.Add(TEvent.Create(Callback))
{$IFDEF DEBUG_EVENTS}
  else
    raise EEvents.Create('Duplicate subscription of '+ClassName+' owned by '+OwnerDesc+'.');
{$ENDIF}
end;

procedure TEvents.InternalUnsubscribe(const Callback: TNotifyEvent);
var
  iCallback, iEnum: integer;
{$IFDEF DEBUG_EVENTS}
  iState: integer;
  State: EventsStates.TState;
{$ENDIF}
begin
  if  DisableAllEvents  then
    exit;
{$IFDEF DEBUG_EVENTS}
  try
{$ENDIF}
    //  Do not unsubscribe what isn't there
    iCallback := IndexOf(Callback);
{$IFDEF DEBUG_EVENTS}
  except
    iState := EventsStates.IndexOf(Self);
    if  iState < 0 then
      raise EEventsStates.Create('Tried to unsubscribe from a TEvents object that has never been instantiated.');
    State := EventsStates._States[iState];
    if  State.IsFreed then
      raise EEventsStates.Create('Tried to unsubscribe from '+State.EventsClassName+' owned by '+State.OwnerClassName+' that has already been freed.');
    raise;
  end;
{$ENDIF}
  if  iCallback >= 0  then
    begin
      for iEnum := 0 to fEnumerators.Count - 1  do
        fEnumerators[iEnum].Removing(iCallback);
      fEvents.Delete(iCallback);
    end
{$IFDEF DEBUG_EVENTS}
  else
    raise EEvents.Create('Unsubscribing unsubscribed event in '+ClassName+' owned by '+OwnerDesc+'.');
{$ENDIF}
end;

function TEvents.IsSameMethod(const Event1, Event2: TNotifyEvent): Boolean;
begin
{$WARN UNSAFE_CAST OFF}
{$WARN UNSAFE_TYPE OFF}
  Result  := (TMethod( Event1 ).Data = TMethod( Event2 ).Data) and
             (TMethod( Event1 ).Code = TMethod( Event2 ).Code)
{$WARN UNSAFE_TYPE ON}
{$WARN UNSAFE_CAST ON}
end;

{$IFDEF DEBUG_EVENTS}
function TEvents.OwnerDesc: string;

  function  FindPropertyName: string;
  var
    Ctx: TRttiContext;
    OwnerType: TRttiType;
    Prop: TRttiProperty;
    Props: TArray<TRttiProperty>;
  begin
    Result  := '???';
    Ctx := TRttiContext.Create;
    try
      OwnerType  := Ctx.GetType(fOwner.ClassType);
      Props := OwnerType.GetProperties;
      for Prop in Props do
        if  Prop.IsReadable then
          if  Prop.PropertyType.TypeKind = tkClass  then
            if  Prop.GetValue(fOwner).AsObject = Self then
              Exit(Prop.Name);
    finally
      Ctx.Free;
    end;
  end;

begin
  if  Assigned(fOwner)  then
    Result  := fOwnerName + '.' + FindPropertyName
  else
    Result  := fOwnerName + '(nil).???'
end;
{$ENDIF}

{
    Because TEvents stores callbacks as TNotifyEvent, we need to typecast
    the events back to TNotifyEvent.

procedure TEvents.Subscribe(const Event: TMyEventType);
begin
  InternalSubscribe(TNotifyEvent(Event));
end;

procedure TEvents.Unsubscribe(const Event: TMyEventType);
begin
  InternalUnsubscribe(TNotifyEvent(Event));
end;
}
{ TNotifyEvents }

procedure TNotifyEvents.Call;
var
  Event : TNotifyEvent;
begin
  if  Enabled then
    for Event in Self do
      Event(Owner)
end;

function TNotifyEvents.IsSubscribed(const Event: TNotifyEvent): Boolean;
begin
  Result  := IndexOf(Event) >= 0
end;

procedure TNotifyEvents.Subscribe(const Event: TNotifyEvent);
begin
  InternalSubscribe(Event);
end;

procedure TNotifyEvents.TryUnsubscribe(const Event: TNotifyEvent);
begin
  if  IsSubscribed(Event) then
    Unsubscribe(Event)
  else
    ShowMessage('TryUnsubscribe() failed.');
end;

procedure TNotifyEvents.Unsubscribe(const Event: TNotifyEvent);
begin
  InternalUnsubscribe(Event);
end;

{ TEvent1Param<TParam> }

procedure TEvent1Param<TParam>.Call(Param: TParam);
var
  Event : TNotifyEvent;
begin
  if  Enabled then
    for Event in Self do
      TCallback1Param(Event)(Owner, Param)
end;

procedure TEvent1Param<TParam>.Subscribe(const Event: TCallback1Param);
begin
  InternalSubscribe(TNotifyEvent(Event));
end;

procedure TEvent1Param<TParam>.Unsubscribe(const Event: TCallback1Param);
begin
  InternalUnsubscribe(TNotifyEvent(Event));
end;

{$IFDEF DEBUG_EVENTS}
{ EventsStates.TState }

constructor EventsStates.TState.Create(const AEvents: TEvents);
begin
  Events          := AEvents;
  IsFreed         := False;
  EventsClassName := Events.ClassName;
  OwnerClassName  := Events.fOwnerName;
end;

{ EventsStates }

class constructor EventsStates.Create;
begin
  _States := TList<TState>.Create;
end;

class destructor EventsStates.Destroy;
begin
  FreeAndNil(_States);
end;

class function EventsStates.GetTotal: integer;
begin
  Result  := _States.Count
end;

class function EventsStates.IndexOf(const Events: TEvents): integer;
begin
  Result  := _States.Count - 1;
  while _States[Result].Events <> Events  do
    dec(Result);
  if  Result < 0  then
    raise EEventsStates.Create('This event has not been registered.');
end;

class procedure EventsStates.Register(const Events: TEvents);
begin
  if  not Assigned(_States) then
    if  Assigned(Events)  then
      raise EEventsStates.Create('Trying to register '+Events.ClassName+' after events have been shut down.')
    else
      raise EEventsStates.Create('Trying to register nil TEvents after events have been shut down.');
  _States.Add(TState.Create(Events))
end;

class procedure EventsStates.Unregister(const Events: TEvents);
var
  i: integer;
  State: TState;

  function ListSubscriptions: string;
  var
    List: TStrings;
    i: integer;
  begin
    List  := TStringList.Create;
    try
      for i := 0 to State.Events.fEvents.Count - 1 do
        List.Add(State.Events.fEvents[i].CallbackDesc);
      Result  := List.Text
    finally
      List.Free;
    end;
  end;

begin
  if  not Assigned(_States) then
    if  Assigned(Events)  then
      raise EEventsStates.Create('Trying to unregister '+Events.ClassName+' after events have been shut down.')
    else
      raise EEventsStates.Create('Trying to unregister nil TEvents after events have been shut down.');
  i := IndexOf(Events);
  State := _States[i];
  //  Check: Already freed
  if  State.IsFreed then
    raise EEventsStates.Create('TEvents of type '+State.EventsClassName+' owned by '+State.OwnerClassName+' has already been freed.');
  State.OwnerClassName  := State.Events.OwnerDesc;
  State.IsFreed := True;
  //  Check: Remaining subscriptions
  if  Events.Count > 0  then
    raise EEventsStates.Create(State.EventsClassName+' owned by '+State.OwnerClassName+' being freed with remaining subscriptions:'+#$D#$A+ListSubscriptions);
  _States[i]  := State;
end;
{$ENDIF}

end.
